home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / alistab.scm < prev    next >
Text File  |  1999-04-19  |  10KB  |  352 lines
  1. ;;; "alistab.scm" database tables using association lists (assoc)
  2. ; Copyright 1994, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; LLDB    is (filename . alist-table)
  21. ;;; HANDLE    is (#(table-name key-dim) . TABLE)
  22. ;;; TABLE    is an alist of (Primary-key . ROW)
  23. ;;; ROW        is a list of non-primary VALUEs
  24.  
  25. (require 'common-list-functions)
  26.  
  27. (define alist-table
  28.   (let ((catalog-id 0)
  29.     (resources '*base-resources*)
  30.     (make-list-keyifier (lambda (prinum types) identity))
  31.     (make-keyifier-1 (lambda (type) list))
  32.     (make-key->list (lambda (prinum types) identity))
  33.     (make-key-extractor (lambda (primary-limit column-type-list index)
  34.                   (let ((i (+ -1 index)))
  35.                 (lambda (lst) (list-ref lst i))))))
  36.  
  37. (define keyify-1 (make-keyifier-1 'atom))
  38.  
  39. (define (make-base filename dim types)
  40.   (list filename
  41.     (list catalog-id)
  42.     (list resources (list 'free-id 1))))
  43.  
  44. (define (open-base infile writable)
  45.   (and (or (input-port? infile) (file-exists? infile))
  46.        (cons (if (input-port? infile) #f infile)
  47.          ((lambda (fun)
  48.         (if (input-port? infile)
  49.             (fun infile)
  50.             (call-with-input-file infile fun)))
  51.           read))))
  52.  
  53. (define (write-base lldb outfile)
  54.   ((lambda (fun)
  55.      (cond ((output-port? outfile) (fun outfile))
  56.        ((string? outfile) (call-with-output-file outfile fun))
  57.        (else #f)))
  58.    (lambda (port)
  59.      (display (string-append
  60.            ";;; \"" outfile "\" SLIB alist-table database     -*-scheme-*-")
  61.           port)
  62.      (newline port) (newline port)
  63.      (display "(" port) (newline port)
  64.      (for-each
  65.       (lambda (table)
  66.     (display " (" port)
  67.     (write (car table) port) (newline port)
  68.     (for-each
  69.      (lambda (row)
  70.        (display "  " port) (write row port) (newline port))
  71.      (cdr table))
  72.     (display " )" port) (newline port))
  73.       (cdr lldb))
  74.      (display ")" port) (newline port)
  75. ;     (require 'pretty-print)
  76. ;     (pretty-print (cdr lldb) port)
  77.      (set-car! lldb (if (string? outfile) outfile #f))
  78.      #t)))
  79.  
  80. (define (sync-base lldb)
  81.   (cond ((car lldb) (write-base lldb (car lldb)) #t)
  82.     (else
  83. ;;;     (display "sync-base: database filename not known")
  84.      #f)))
  85.  
  86. (define (close-base lldb)
  87.   (cond ((car lldb) (write-base lldb (car lldb))
  88.             (set-cdr! lldb #f)
  89.             (set-car! lldb #f) #t)
  90.     ((cdr lldb) (set-cdr! lldb #f)
  91.             (set-car! lldb #f) #t)
  92.     (else
  93. ;;;     (display "close-base: database not open")
  94.      #f)))
  95.  
  96. (define (make-table lldb dim types)
  97.   (let ((free-hand (open-table lldb resources 1 '(atom integer))))
  98.     (and free-hand
  99.      (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand)))
  100.         (table-id #f))
  101.        (cond (row
  102.           (set! table-id (cadr row))
  103.           (set-car! (cdr row) (+ 1 table-id))
  104.           (set-cdr! lldb (cons (list table-id) (cdr lldb)))
  105.           table-id)
  106.          (else #f))))))
  107.  
  108. (define (open-table lldb base-id dim types)
  109.   (assoc base-id (cdr lldb)))
  110.  
  111. (define (kill-table lldb base-id dim types)
  112.   (define ckey (list base-id))
  113.   (let ((pair (assoc* ckey (cdr lldb))))
  114.     (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb))))
  115.     (and pair (not (assoc* ckey (cdr lldb))))))
  116.  
  117. (define handle->alist cdr)
  118. (define set-handle-alist! set-cdr!)
  119.  
  120. (define (assoc* keys alist)
  121.   (let ((pair (assoc (car keys) alist)))
  122.     (cond ((not pair) #f)
  123.       ((null? (cdr keys)) pair)
  124.       (else (assoc* (cdr keys) (cdr pair))))))
  125.  
  126. (define (make-assoc* keys alist vals)
  127.   (let ((pair (assoc (car keys) alist)))
  128.     (cond ((not pair) (cons (cons (car keys)
  129.                   (if (null? (cdr keys))
  130.                       vals
  131.                       (make-assoc* (cdr keys) '() vals)))
  132.                 alist))
  133.       (else (set-cdr! pair (if (null? (cdr keys))
  134.                    vals
  135.                    (make-assoc* (cdr keys) (cdr pair) vals)))
  136.         alist))))
  137.  
  138. (define (delete-assoc ckey alist)
  139.   (cond
  140.    ((null? ckey) '())
  141.    ((assoc (car ckey) alist)
  142.     => (lambda (match)
  143.      (let ((adl (delete-assoc (cdr ckey) (cdr match))))
  144.        (cond ((null? adl) (delete match alist))
  145.          (else (set-cdr! match adl) alist)))))
  146.    (else alist)))
  147.  
  148. (define (delete-assoc* ckey alist)
  149.   (cond
  150.    ((every not ckey) '())        ;includes the null case.
  151.    ((not (car ckey))
  152.     (delete '()
  153.         (map (lambda (fodder)
  154.            (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
  155.              (if (null? adl) '() (cons (car fodder) adl))))
  156.          alist)))
  157.    ((procedure? (car ckey))
  158.     (delete '()
  159.         (map (lambda (fodder)
  160.            (if ((car ckey) (car fodder))
  161.                (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
  162.              (if (null? adl) '() (cons (car fodder) adl)))
  163.                fodder))
  164.          alist)))
  165.    ((assoc (car ckey) alist)
  166.     => (lambda (match)
  167.      (let ((adl (delete-assoc* (cdr ckey) (cdr match))))
  168.        (cond ((null? adl) (delete match alist))
  169.          (else (set-cdr! match adl) alist)))))
  170.    (else alist)))
  171.  
  172. (define (assoc*-for-each proc bkey ckey alist)
  173.   (cond ((null? ckey) (proc (reverse bkey)))
  174.     ((not (car ckey))
  175.      (for-each (lambda (alist)
  176.              (assoc*-for-each proc
  177.                       (cons (car alist) bkey)
  178.                       (cdr ckey)
  179.                       (cdr alist)))
  180.            alist))
  181.     ((procedure? (car ckey))
  182.      (for-each (lambda (alist)
  183.              (if ((car ckey) (car alist))
  184.              (assoc*-for-each proc
  185.                       (cons (car alist) bkey)
  186.                       (cdr ckey)
  187.                       (cdr alist))))
  188.            alist))
  189.     ((assoc (car ckey) alist)
  190.      => (lambda (match)
  191.           (assoc*-for-each proc
  192.                    (cons (car match) bkey)
  193.                    (cdr ckey)
  194.                    (cdr match))))))
  195.  
  196. (define (assoc*-map proc bkey ckey alist)
  197.   (cond ((null? ckey) (list (proc (reverse bkey))))
  198.     ((not (car ckey))
  199.      (apply append
  200.         (map (lambda (alist)
  201.                (assoc*-map proc
  202.                    (cons (car alist) bkey)
  203.                    (cdr ckey)
  204.                    (cdr alist)))
  205.              alist)))
  206.     ((procedure? (car ckey))
  207.      (apply append
  208.         (map (lambda (alist)
  209.                (if ((car ckey) (car alist))
  210.                (assoc*-map proc
  211.                        (cons (car alist) bkey)
  212.                        (cdr ckey)
  213.                        (cdr alist))
  214.                '()))
  215.              alist)))
  216.     ((assoc (car ckey) alist)
  217.      => (lambda (match)
  218.           (assoc*-map proc
  219.               (cons (car match) bkey)
  220.               (cdr ckey)
  221.               (cdr match))))
  222.     (else '())))
  223.  
  224. (define (sorted-assoc*-for-each proc bkey ckey alist)
  225.   (cond ((null? ckey) (proc (reverse bkey)))
  226.     ((not (car ckey))
  227.      (for-each (lambda (alist)
  228.              (sorted-assoc*-for-each proc
  229.                          (cons (car alist) bkey)
  230.                          (cdr ckey)
  231.                          (cdr alist)))
  232.            (alist-sort! alist)))
  233.     ((procedure? (car ckey))
  234.      (sorted-assoc*-for-each proc
  235.                  bkey
  236.                  (cons #f (cdr ckey))
  237.                  (remove-if-not (lambda (pair)
  238.                           ((car ckey) (car pair)))
  239.                         alist)))
  240.     ((assoc (car ckey) alist)
  241.      => (lambda (match)
  242.           (sorted-assoc*-for-each proc
  243.                       (cons (car match) bkey)
  244.                       (cdr ckey)
  245.                       (cdr match))))))
  246.  
  247. (define (alist-sort! alist)
  248.   (define (key->sortable k)
  249.     (cond ((number? k) k)
  250.       ((string? k) k)
  251.       ((symbol? k) (symbol->string k))
  252.       ((vector? k) (map key->sortable (vector->list k)))
  253.       (else (slib:error "unsortable key" k))))
  254.   ;; This routine assumes that the car of its operands are either
  255.   ;; numbers or strings (or lists of those).
  256.   (define (car-key-< x y)
  257.     (key-< (car x) (car y)))
  258.   (define (key-< x y)
  259.     (cond ((and (number? x) (number? y)) (< x y))
  260.       ((number? x) #t)
  261.       ((number? y) #f)
  262.       ((string? x) (string<? x y))
  263.       ((key-< (car x) (car y)) #t)
  264.       ((key-< (car y) (car x)) #f)
  265.       (else (key-< (cdr x) (cdr y)))))
  266.   (require 'sort)
  267.   (map cdr (sort! (map (lambda (p)
  268.              (cons (key->sortable (car p)) p))
  269.                alist)
  270.           car-key-<)))
  271.  
  272. (define (present? handle ckey)
  273.   (assoc* ckey (handle->alist handle)))
  274.  
  275. (define (make-putter prinum types)
  276.   (lambda (handle ckey restcols)
  277.     (set-handle-alist! handle
  278.                (make-assoc* ckey (handle->alist handle) restcols))))
  279.  
  280. (define (make-getter prinum types)
  281.   (lambda (handle ckey)
  282.     (let ((row (assoc* ckey (handle->alist handle))))
  283.       (and row (cdr row)))))
  284.  
  285. (define (for-each-key handle operation match-key)
  286.   (assoc*-for-each operation
  287.            '()
  288.            match-key
  289.            (handle->alist handle)))
  290.  
  291. (define (map-key handle operation match-key)
  292.   (assoc*-map operation
  293.           '()
  294.           match-key
  295.           (handle->alist handle)))
  296.  
  297. (define (ordered-for-each-key handle operation match-key)
  298.   (sorted-assoc*-for-each operation
  299.               '()
  300.               match-key
  301.               (handle->alist handle)))
  302.  
  303. (define (supported-type? type)
  304.   (case type
  305.     ((base-id atom integer boolean string symbol expression number) #t)
  306.     (else #f)))
  307.  
  308. (define (supported-key-type? type)
  309.   (case type
  310.     ((atom integer number symbol string) #t)
  311.     (else #f)))
  312.  
  313. ;;make-table open-table remover assoc* make-assoc*
  314. ;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each)
  315.  
  316.     (lambda (operation-name)
  317.       (case operation-name
  318.     ((make-base) make-base)
  319.     ((open-base) open-base)
  320.     ((write-base) write-base)
  321.     ((sync-base) sync-base)
  322.     ((close-base) close-base)
  323.     ((catalog-id) catalog-id)
  324.     ((make-table) make-table)
  325.     ((open-table) open-table)
  326.     ((kill-table) kill-table)
  327.     ((make-keyifier-1) make-keyifier-1)
  328.     ((make-list-keyifier) make-list-keyifier)
  329.     ((make-key->list) make-key->list)
  330.     ((make-key-extractor) make-key-extractor)
  331.     ((supported-type?) supported-type?)
  332.     ((supported-key-type?) supported-key-type?)
  333.     ((present?) present?)
  334.     ((make-putter) make-putter)
  335.     ((make-getter) make-getter)
  336.     ((delete)
  337.      (lambda (handle ckey)
  338.        (set-handle-alist! handle
  339.                   (delete-assoc ckey (handle->alist handle)))))
  340.     ((delete*)
  341.      (lambda (handle match-key)
  342.        (set-handle-alist! handle
  343.                   (delete-assoc* match-key
  344.                          (handle->alist handle)))))
  345.     ((for-each-key) for-each-key)
  346.     ((map-key) map-key)
  347.     ((ordered-for-each-key) ordered-for-each-key)
  348.     (else #f)))
  349.     ))
  350.  
  351. ;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)
  352.